home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 007 / tbbyte.arc / PRINTTUR.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1985-08-16  |  11.3 KB  |  334 lines
  1.  
  2. program plist(input, output);
  3. (* Pretty print with date/time stamp for Turbo Pascal programs.
  4.   Written by: Rick Schaeffer
  5.               E. 13611 26th Av.
  6.               Spokane, Wa.  99216
  7.  
  8.   modifications (7/8/84  by Len Whitten, CIS: [73545,1006])
  9.      1) added error handling if file not found
  10.      2) added default extension of .PAS to main & include files
  11.      3) added "WhenCreated" procedure to extract file
  12.         creation date & time from TURBO FIB
  13.      4) added demarcation of where include file ends
  14.      5) added upper char. conversion to include file
  15.      6) increased left margin to 5 spaces (80 char. line just fits @ 10cpi)
  16.      7) added listing control: {.L-} turns it off, {.L+} turns it back on,
  17.         must be in column 1
  18.      
  19.   further modifications (7/12/84 by Rick Schaeffer)
  20.      1) cleaned up the command line parsing routines and put them in
  21.         separate procedures.  Now permits any number of command line
  22.         arguments, each argument separated with at least one space.
  23.      2) added support for an optional second command line parameter
  24.         which specifies whether include files will be listed or not.
  25.         The command is invoked by placing "/i" on the command line
  26.         at least one space after the file name to be listed.  For
  27.         instance, to list MYPROG.PAS as well as any "included" files,
  28.         the command line would be: PLIST MYPROG /I
  29.  
  30.         Further modifications ( 4/22/85 by Steve Griffin )
  31.           Changed the file date and time routines to go through
  32.           DOS rather than use the FIB in Turbo. The FIB is set up
  33.           differently for Turbo 3.0 and this version should work
  34.           with Turbo 2.0 or 3.0 .  I believe that Microsoft has made
  35.           a change in DOS 3.x so that the success codes for file
  36.           operations have changed from 2.x . Beware if you try to
  37.           run this under DOS 3.x .
  38. *)
  39.  
  40. type
  41.    filrec = Record                          (* DTA layout        *)
  42.       file_ForD   : array[1..21]of byte;    (* reserved for DOS  *)
  43.       file_Attr   : byte;                   (* file attribute    *)
  44.       file_Time   : integer;                (* file time         *)
  45.       file_Date   : integer;                (* file date         *)
  46.       file_Size   : array[1..4] of byte;    (* file size         *)
  47.       file_Name   : array[1..13] of Char;   (* file name         *)
  48.       file_Fill   : array[1..85] of byte;   (* filler - ?????    *)
  49.    End;
  50.    fnmtype = string[14];
  51.    instring = string[132];
  52.    dtstr = string[8];
  53.    two_letters = string[2];
  54.    regpack = record
  55.       ax,bx,cx,dx,bp,si,di,ds,es,flags : integer;
  56.    end;
  57.  
  58. const monthmask = $000F;
  59.       daymask = $001F;
  60.       minutemask = $003F;
  61.       secondmask = $001F;
  62.  
  63. var
  64.    expand_includes     : boolean;
  65.    holdarg             : instring;
  66.    mainflnm            : fnmtype;
  67.    filefcb             : filrec;
  68.    linecnt, pageno,
  69.    offset,i,j          : integer;
  70.    done                : boolean;
  71.    sysdate, systime,
  72.    filedate, filetime  : dtstr;
  73.    month,day,year,
  74.    hour,minute,second  : two_letters;
  75.    allregs             : regpack;
  76.  
  77. procedure fill_blanks (var line: dtstr);
  78.  
  79. begin
  80.   for i:= 1 to 8 do if line[i] = ' ' then line[i]:= '0';
  81. end;  {fill_blanks}
  82.  
  83. procedure getdate(var date : dtstr);
  84.  
  85. begin
  86.    allregs.ax := $2A * 256;
  87.    MsDos(allregs);
  88.    str((allregs.dx div 256):2,month);
  89.    str((allregs.dx mod 256):2,day);
  90.    str((allregs.cx - 1900):2,year);
  91.    date := month + '/' + day + '/' + year;
  92.    fill_blanks (date);
  93. end;  {getdate}
  94.  
  95. procedure gettime(var time : dtstr);
  96.  
  97. begin
  98.    allregs.ax := $2C * 256;
  99.    MsDos(allregs);
  100.    str((allregs.cx div 256):2,hour);
  101.    str((allregs.cx mod 256):2,minute);
  102.    str((allregs.dx div 256):2,second);
  103.    time := hour + ':' + minute + ':' + second;
  104.    fill_blanks (time);
  105. end;  {gettime}
  106.  
  107.  
  108. procedure WhenCreated (var date, time: dtstr; var filename: fnmtype);
  109.  
  110. var fulltime,fulldate,DTAds,DTAdx: integer;
  111.     filesearch: fnmtype;
  112.  
  113.  
  114.   Begin         (* Get file date and time through DOS calls       *)
  115.                 (* to make program independent of Turbo versions. *)
  116.  
  117.                 (* Get current DTA and save location              *)
  118.  
  119.    allregs.ax := $2F00;
  120.    Intr($21,allregs);
  121.    DTAds := allregs.es;
  122.    DTAdx := allregs.bx;
  123.  
  124.                 (* Set up DTA to recieve FCB of file.             *)
  125.  
  126.    allregs.ax := $1A00;
  127.    allregs.dx := ofs(filefcb);
  128.    allregs.ds := Dseg;
  129.    Intr($21,allregs);
  130.  
  131.                 (* Search for file to print.                      *)
  132.  
  133.    allregs.ax := $4E00;
  134.    allregs.cx := $37;
  135.    filesearch := filename + chr(0);
  136.    allregs.dx := ofs(filesearch) + 1;
  137.    allregs.ds := Seg(filesearch);
  138.    Intr($21,allregs);
  139.    If Lo(allregs.ax) <> 0 then    (* Note that PCDOS 3.x uses a    *)
  140.                                   (* different flag for successful *)
  141.                                   (* file search, I believe.       *)
  142.      Begin
  143.         Writeln('          File ',filename,' not found.');
  144.         If Lo(allregs.ax) = 2 Then Writeln('          Drive not ready.');
  145.         If Lo(allregs.ax) = 18 Then Writeln('          No file by that name');
  146.         HALT;
  147.      End;
  148.  
  149.              (* Restore DTA to previous location.               *)
  150.  
  151.    allregs.ax := $1A00;
  152.    allregs.dx := DTAdx;
  153.    allregs.ds := DTAds;
  154.    Intr($21,allregs);
  155.  
  156. {fulldate  corresponds to bytes 20-21
  157.  of the FCB.                 Format is: bits 0 - 4: day of month
  158.                                              5 - 8: month of year
  159.                                              9 -15: year - 1980     }
  160.  
  161.     with filefcb do begin
  162.       fulldate := file_Date;
  163.     end;
  164.     str(((fulldate shr 9) + 80):2,year);
  165.     str(((fulldate shr 5) and monthmask):2,month);
  166.     str((fulldate and daymask):2,day);
  167.     date:= month + '/' + day + '/' + year;
  168.     fill_blanks(date);
  169.  
  170.  
  171. {fulltime  corresponds to bytes 22-23
  172.  of the FCB.                     Format is: bits 0 - 4: seconds/2
  173.                                                  5 -10: minutes
  174.                                                  11-15: hours         }
  175.  
  176.     with filefcb do begin
  177.       fulltime := file_Time;
  178.     end;
  179.     str((fulltime shr 11):2,hour);
  180.     str(((fulltime shr 5) and minutemask):2,minute);
  181.     str(((fulltime and secondmask) * 2):2,second);
  182.     time:= hour + ':' + minute + ':' + second;
  183.     fill_blanks (time);
  184. end;  {WhenCreated}
  185.  
  186. function chkinc(var iptline : instring; var incflname : fnmtype) : boolean;
  187. var
  188.    done : boolean;
  189. begin
  190.    i := 4; j := 1; incflname := '';
  191.    if copy(iptline, 1, 3) = '{$I' then begin
  192.       i := 4; j := 1; incflname := '';
  193.       while (iptline[i] = ' ') and (i <= length(iptline)) do i := i + 1;
  194.       done := false;
  195.       while not done do begin
  196.          if i <= length(iptline) then begin
  197.             if not (iptline[i] in [' ','}','+','-']) then begin
  198.                incflname[j] := iptline[i];
  199.                i := i + 1; j := j + 1;
  200.             end else done := true;
  201.          end else done := true;
  202.          if j > 14 then done := true;
  203.       end;
  204.       incflname[0] := chr(j - 1);
  205.    end;
  206.    if incflname <> '' then chkinc := true else chkinc := false;
  207. end;  {chkinc}
  208.  
  209. procedure print_heading(filename : fnmtype);
  210.  
  211. var offset_inc: integer;
  212.  
  213. begin
  214.    if linecnt <> 66 then write(lst,^L);
  215.    pageno := pageno + 1;
  216.    write(lst,'     TURBO Pascal Program Lister');
  217.    writeln(lst,' ':8,'Printed: ',sysdate,'  ',systime,'   Page ',pageno:4);
  218.    if filename <> mainflnm then begin
  219.       offset_inc:= 14 - length (filename);
  220.       write(lst,'     Include File: ',filename,' ':offset_inc,
  221.          'Created: ',filedate,'  ',filetime);
  222.    end
  223.    else write(lst,'     Main File: ',mainflnm,' ':offset,
  224.          'Created: ',filedate,'  ',filetime);
  225.    writeln(lst);
  226.    writeln(lst); writeln(lst);
  227.    linecnt := 1;
  228. end;  {print_heading}
  229.  
  230. procedure printline(iptline : instring; filename : fnmtype);
  231. begin
  232.    if linecnt < 56 then begin
  233.       writeln(lst,'     ',iptline);
  234.       linecnt := linecnt + 1;
  235.    end else begin
  236.       print_heading(filename);
  237.       writeln(lst,'     ',iptline);
  238.    end;
  239. end;  {printline}
  240.  
  241. procedure listit(filename : fnmtype);
  242.  
  243. var
  244.    infile    : text;
  245.    iptline   : instring;
  246.    incflname : fnmtype;
  247.    print     : boolean;
  248.  
  249. begin
  250.    print:= true;
  251.    assign(infile, filename);
  252.    {$I-} reset(infile) {$I+} ;
  253.    if IOresult <> 0 then begin
  254.       writeln ('File ',filename,' not found.');
  255.       halt;
  256.    end;
  257.    WhenCreated (filedate,filetime,filename);
  258.    while not eof(infile) do begin
  259.       readln(infile, iptline);
  260.       if copy(iptline, 1, 4) = '{.L-' then print:= false;
  261.       if print then begin
  262.          if (chkinc(iptline, incflname) and (expand_includes)) then begin
  263.             for i := 1 to length(incflname) do
  264.               incflname[i] := upcase(incflname[i]);
  265.             if pos('.',incflname) = 0 then incflname := incflname + '.PAS';
  266.             printline('*************************************',filename);
  267.             printline('    Including "'+incflname+'"', filename);
  268.             printline('*************************************',filename);
  269.             listit(incflname);
  270.             printline('*************************************',filename);
  271.             printline('    End of    "'+incflname+'"', filename);
  272.             printline('*************************************',filename);
  273.          end  {include file check}
  274.          else begin
  275.             if copy(iptline, 1, 4) = '{.PA' then print_heading(filename)
  276.             else printline(iptline, filename);
  277.          end  {line printing}
  278.       end  {listing control}
  279.       else if copy(iptline, 1, 4) = '{.L+' then print:= true;
  280.    end;  {file reading}
  281.    close(infile);
  282. end;  {listit}
  283.  
  284. function parse_cmd(argno : integer) : instring;
  285. var
  286.    i,j : integer;
  287.    wkstr : instring;
  288.    done : boolean;
  289.    cmdline : ^instring;
  290. begin
  291.    cmdline := ptr(CSEG,$0080);
  292.    wkstr := '';
  293.    done := false; i := 1; j := 0;
  294.    if length(cmdline^) < i then done := true;
  295.    repeat
  296.       while ((cmdline^[i] = ' ') and (not done)) do begin
  297.          i := i + 1;
  298.          if i > length(cmdline^) then done := true;
  299.       end;
  300.       if not done then j := j + 1;
  301.       while ((cmdline^[i] <> ' ') and (not done)) do begin
  302.          wkstr := wkstr + cmdline^[i];
  303.          i := i + 1;
  304.          if i > length(cmdline^) then done := true;
  305.       end;
  306.       if (j <> argno) then wkstr := '';
  307.    until (done or (j = argno));
  308.    for i := 1 to length(wkstr) do
  309.       wkstr[i] := upcase(wkstr[i]); {all arguments forced to upper case}
  310.    parse_cmd := wkstr;
  311. end;
  312.  
  313. begin {main program}
  314.    getdate(sysdate);
  315.    gettime(systime);
  316.    linecnt := 66; pageno := 0;
  317.    writeln;
  318.    writeln('TURBO Pascal Formatted Listing');
  319.    holdarg := parse_cmd(1); {get command line argument # 1}
  320.    if length(holdarg) <= 14 then mainflnm := holdarg;
  321.    holdarg := parse_cmd(2); {get optional command line argument # 2}
  322.    if holdarg = '/I' then expand_includes := true
  323.       else expand_includes := false;
  324.    if mainflnm = '' then begin
  325.       write('Enter file name: ');
  326.       readln(mainflnm);
  327.    end;
  328.    if pos('.',mainflnm) = 0 then mainflnm := mainflnm + '.PAS';
  329.    offset:= 24 - length (mainflnm);
  330.    listit(mainflnm);
  331.    write(lst,^L);
  332.    write(lst,^L);
  333. end.
  334.